home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / gsdbloo.exe / GS_STRNG.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-02-24  |  12.3 KB  |  351 lines
  1. unit GS_Strng;
  2. {-----------------------------------------------------------------------------
  3.                            String Handling Routines
  4.  
  5.        GS_Strng Copyright (c)  Richard F. Griffin
  6.  
  7.         1 January 1991
  8.  
  9.        102 Molded Stone Pl
  10.        Warner Robins, GA  31088
  11.  
  12.        -------------------------------------------------------------
  13.        This unit handles the routines for string handling.
  14.  
  15. Changes:
  16.          13 Apr 91 - Added function Strip_Flip.  This function will remove
  17.                      trailing spaces and move any part of the string that
  18.                      is preceeded by a '~' to the end of the string.
  19.                      For Example:
  20.                                  Smith~John X.
  21.                           will be converted to:
  22.                                  John X. Smith
  23.                           on return.
  24.  
  25.                      This is ideal for maintaining a name alphabetically
  26.                      while allowing a simple function to make the name
  27.                      'normal' on display.
  28.  
  29.          02 May 91 - Converted StrDate to accept a longint and convert to the
  30.                      MM/DD/YY string format.  The longint value is the julian
  31.                      date (for example, 1 Jan 90 has a julian date of 2447893)
  32.  
  33.                      Added a ValDate function to convert a date string of
  34.                      either MM/DD/YY or YYYYMMDD to the longint juilian day.
  35.  
  36.          10 Aug 91 - Modified Unique_Field to return a unique field that can
  37.                      also serve as a FileName.  First character is alpha and
  38.                      othere are alpha(uppercase) or numeric.  Previously, the
  39.                      routine returned uppercase, lowercase, and special chars.
  40.  
  41. ------------------------------------------------------------------------------}
  42.  
  43. interface
  44. {$D-}
  45.  
  46. uses
  47.    Crt,
  48.    Dos,
  49.    GS_Date;
  50.  
  51. function AllCaps(var t : string) : string;
  52. procedure CnvAscToStr(var asc, st; lth : integer);
  53. procedure CnvStrToAsc(var st, asc; lth : integer);
  54. function Strip_Flip(st : string) : string;
  55. function StrDate(jul : longint) : string;
  56. function StrNumber(num : real; lth,dec : integer) : string;
  57. function StrLogic(tf : boolean) : string;
  58. function SubStr(s : string; b,l : integer) : string;
  59. function TrimL(strn : string):string; {Deletes leading spaces}
  60. function TrimR(strn : string):string; {Deletes trailing spaces}
  61. function Unique_Field : string;       {Used to create a unique 8-byte string}
  62. function ValDate(strn : string) : longint;
  63. function ValNumber(strn : string) : real;
  64. function ValLogic(strn : string) : boolean;
  65.  
  66.  
  67. implementation
  68.  
  69. function AllCaps(var t : string) : string;
  70. var
  71.    i : integer;
  72.    s : string;
  73. begin
  74.    s := t;
  75.    for i := 1 to length(s) do s[i] := upcase(s[i]);
  76.    AllCaps := s;
  77. end;
  78.  
  79. procedure CnvAscToStr(var asc, st; lth : integer);
  80. var
  81.    a : array[0..255] of byte absolute asc;
  82.    s : string[255] absolute st;
  83.    i : integer;
  84. begin
  85.    move(a,s[1],lth);
  86.    s[0] := chr(lth);
  87.    i := pos(#0,s);
  88.    if i > 0 then dec(i)
  89.       else if a[0] <> 0 then i := lth;
  90.    s[0] := chr(i);
  91. end;
  92.  
  93. procedure CnvStrToAsc(var st, asc; lth : integer);
  94. var
  95.    a : array[0..255] of byte absolute asc;
  96.    s : string[255] absolute st;
  97.    t : string;
  98.    i : integer;
  99. begin
  100.    t := s;
  101.    FillChar(a,lth,#0);
  102.    i := length(t);
  103.    if i >= lth then i := lth;
  104.    move(t[1],a,i);
  105. end;
  106.  
  107. Function Strip_Flip(st : string) : string;
  108. var
  109.    wst,
  110.    wstl : string;
  111.    i    : integer;
  112. begin
  113.    wst := TrimR(st);
  114.    wst := wst + ' ';
  115.    i := pos('~', wst);
  116.    if i <> 0 then
  117.    begin
  118.       wstl := substr(wst,1,pred(i));
  119.       system.delete(wst,1,i);
  120.       wst := wst + wstl;
  121.    end;
  122.    Strip_Flip := wst;
  123. end;
  124.  
  125. function StrDate(jul : longint) : string;
  126. begin
  127.    StrDate := GS_Date_View(jul);
  128. end;
  129.  
  130. function StrNumber(num : real; lth,dec : integer) : string;
  131. var
  132.    s : string;
  133. begin
  134.    Str(num:lth:dec,s);
  135.    StrNumber := s;
  136. end;
  137.  
  138. function StrLogic(tf : boolean) : string;
  139. begin
  140.    if tf then StrLogic := 'T' else StrLogic := 'F';
  141. end;
  142.  
  143. {.pa}
  144. {
  145.  
  146.                                    SUBSTR
  147.  
  148.      ╔══════════════════════════════════════════════════════════════════╗
  149.      ║                                                                  ║
  150.      ║   The SUBSTR function extracts a substring from a string.        ║
  151.      ║                                                                  ║
  152.      ║       Calling the Method:                                        ║
  153.      ║                                                                  ║
  154.      ║               x := SubStr(s,b,l)                                 ║
  155.      ║                                                                  ║
  156.      ║               ( where x is the string to be trimmed.             ║
  157.      ║                       s is of type string.                       ║
  158.      ║                       b is the integer start of substring.       ║
  159.      ║                       l is the integer length of substring.      ║
  160.      ║                                                                  ║
  161.      ║                                                                  ║
  162.      ║       Result:                                                    ║
  163.      ║                                                                  ║
  164.      ║           A substring of l positions beginning at b is returned. ║
  165.      ║                                                                  ║
  166.      ╚══════════════════════════════════════════════════════════════════╝
  167. }
  168.  
  169.  
  170. Function SubStr(s : string; b,l : integer) : string;
  171. var
  172.    st : string;
  173.    i  : integer;
  174. begin
  175.    st := '';
  176.    if b < 0 then b := 1;
  177.    st := copy(s, b, l);
  178.    SubStr := st;
  179. end;
  180. {.pa}
  181. {
  182.  
  183.                                     TRIML
  184.  
  185.      ╔══════════════════════════════════════════════════════════════════╗
  186.      ║                                                                  ║
  187.      ║   The TRIML function removes leading spaces from a field.        ║
  188.      ║                                                                  ║
  189.      ║       Calling the Method:                                        ║
  190.      ║                                                                  ║
  191.      ║                d := TrimL(x)                                     ║
  192.      ║                                                                  ║
  193.      ║               ( where x is the string to be trimmed.             ║
  194.      ║                       d is of type string.                       ║
  195.      ║                                                                  ║
  196.      ║       Result:                                                    ║
  197.      ║                                                                  ║
  198.      ║           Leading spaces are removed and the field returned.     ║
  199.      ║                                                                  ║
  200.      ╚══════════════════════════════════════════════════════════════════╝
  201. }
  202.  
  203.  
  204. function TrimL(strn : string) : string;
  205. var
  206.    st : string;
  207. begin
  208.    st := strn;                        {Load work string}
  209.    while (length(st) > 0) and (st[1] = ' ') do delete(st, 1, 1);
  210.                                       {Loop to delete leading spaces}
  211.    TrimL := st;                       {Return trimmed string}
  212. end;
  213. {.pa}
  214. {
  215.  
  216.                                     TRIMR
  217.  
  218.      ╔══════════════════════════════════════════════════════════════════╗
  219.      ║                                                                  ║
  220.      ║   The TRIMR function removes trailing spaces from a field.       ║
  221.      ║                                                                  ║
  222.      ║       Calling the Method:                                        ║
  223.      ║                                                                  ║
  224.      ║                d := TrimR(x)                                     ║
  225.      ║                                                                  ║
  226.      ║               ( where x is the string to be trimmed.             ║
  227.      ║                       d is of type string.                       ║
  228.      ║                                                                  ║
  229.      ║       Result:                                                    ║
  230.      ║                                                                  ║
  231.      ║           Trailing spaces are removed and the field returned.    ║
  232.      ║                                                                  ║
  233.      ╚══════════════════════════════════════════════════════════════════╝
  234. }
  235.  
  236.  
  237. function TrimR(strn : string) : string;
  238. var
  239.    l  : integer;
  240.    st : string;
  241. begin
  242.    st := strn;                        {Load work string}
  243.    l := length(st);                   {Load string length}
  244.    st[0] := '*';                      {Ensure string length is not decimal 32,}
  245.                                       {which is an ASCII space}
  246.    while st[l] = ' ' do dec(l);       {Loop searching down to first non-blank}
  247.    st[0] := chr(l);                   {Set string to new length}
  248.    TrimR := st;                       {Return trimmed length}
  249. end;
  250.  
  251. {
  252.  
  253.                                  UNIQUE_FIELD
  254.  
  255.      ╔══════════════════════════════════════════════════════════════════╗
  256.      ║                                                                  ║
  257.      ║   The UNIQUE-FIELD function creates an eight-character unique    ║
  258.      ║   value which may be used as a unique field for a database       ║
  259.      ║   record.  The value is based on the data and time of the        ║
  260.      ║   function call, and is down to hundredths of a second.  Thus,   ║
  261.      ║   each value returned will be unique.                            ║
  262.      ║                                                                  ║
  263.      ║       Calling the Method:                                        ║
  264.      ║                                                                  ║
  265.      ║                d := Unique_Field                                 ║
  266.      ║                                                                  ║
  267.      ║               ( where d is a string of length 8.                 ║
  268.      ║                                                                  ║
  269.      ║       Result:                                                    ║
  270.      ║                                                                  ║
  271.      ║           An 8-byte unique string of characters is returned.     ║
  272.      ║                                                                  ║
  273.      ╚══════════════════════════════════════════════════════════════════╝
  274. }
  275. const
  276.    chrsavail : string[36]
  277.              = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  278.  
  279. function Unique_Field : string;
  280. var
  281.    y, mo, d, dow  : Word;
  282.    h, mn, s, hund : Word;
  283.    hundchk        : Word;
  284.    wk, ymd, hms   : longint;
  285.    LS             : string;
  286.  
  287. {
  288.                    ┌──────────────────────────────────────┐
  289.                    │  Beginning of Unique_Field function  │
  290.                    └──────────────────────────────────────┘
  291. }
  292. begin
  293.    GetTime(h,mn,s,hund);           {Call TP 5.5 procedure for current time}
  294.    hundchk := hund;
  295.    repeat
  296.       GetTime(h,mn,s,hund);        {Call TP 5.5 procedure for current time}
  297.    until hundchk <> hund;             {Ensures always a unique time}
  298.    GetDate(y,mo,d,dow);            {Call TP 5.5 procedure for current date}
  299.    ymd := 10000+(mo*100)+d;
  300.    hms := ((h+10)*1000000)+(mn*10000)+(s*100)+hund;
  301.    wk := ymd mod 26;
  302.    LS := chrsavail[succ(wk) + 10];
  303.    ymd := ymd div 26;
  304.    repeat
  305.       wk := ymd mod 36;
  306.       LS := LS + chrsavail[succ(wk)];
  307.       ymd := ymd div 36;
  308.    until ymd = 0;
  309.    repeat
  310.       wk := hms mod 36;
  311.       LS := LS + chrsavail[succ(wk)];
  312.       hms := hms div 36;
  313.    until hms= 0;
  314.    Unique_Field := LS;                {Return the unique field}
  315.  end;
  316.  
  317.  
  318.  
  319. function ValDate(strn : string) : longint;
  320. var
  321.    v : longint;
  322. begin
  323.    v := GS_Date_Juln(strn);
  324.    if v > 0 then ValDate := v else ValDate := 0;
  325. end;
  326.  
  327. function ValNumber(strn : string) : real;
  328. var
  329.    r : integer;
  330.    n : real;
  331. begin
  332.    val(strn,n,r);
  333.    if r <> 0 then ValNumber := 0
  334.       else ValNumber := n;
  335. end;
  336.  
  337. function ValLogic(strn : string) : boolean;
  338. var
  339.    c : char;
  340. begin
  341.    if strn[0] <> #1 then ValLogic := false
  342.    else
  343.    begin
  344.       c := strn[1];
  345.       if c in ['T','t','Y','y'] then ValLogic := true
  346.          else ValLogic := false;
  347.    end;
  348. end;
  349.  
  350.  
  351. end.